perm filename JJUST.F4[MSS,LCS] blob
sn#143870 filedate 1975-02-04 generic text, type T, neo UTF8
00100 SUBROUTINE JJUST
00200 DATA RSP/.5/,RI/4.5/
00220 COMMON JY,L,RJH,RJD,RDIS
00300 COMMON/Q/ RN(20000),PWDS(2500),V(200)
00400 1,RSTFAC(120),STFF(120),R(2,1500),JR(120),P1,P2,I,M
00600
00650 DIMENSION IR(2,1500)
00675 EQUIVALENCE (R,IR)
00700 JJB=-1
00710 IX=PWDS(I+1)-1
00800 JB=0
00900 RRT=P2
01000 RZRO=P1
01050 RJD=P1
01100 IF(RRT.EQ.0)RRT=200
01200 IF(RZRO.EQ.0)RZRO=.001
01300 JCNT=0
01400 RJSZ=RI
01500 CC RJF=0
01600 RJK=0
01700 19 IF(JCNT.GT.9)GO TO 101
01800 ROV=RRT
01900 RJSZ=RJSZ-.2
02000 JCNT=JCNT+1
02100 C TEMPORARY COUNTER
02200 ML=1
02300 TYPE 111,JCNT
02350 111 FORMAT(I4)
02400
02500 DO 11 KN=1,M*8
02600 RSPC=0
02610 MQ=MOD(KN,8)
02620 IF(MQ.EQ.0)MQ=8
02630 MQ=MQ-4
02640 RJH=MQ
02700 CC RJH=KN
02800 N=0
02900
03000 DO 2 K=1,I
03100 L=PWDS(K)
03200 RA=RN(L+1)
03300 RB=RN(L+2)
03400 IF(((RN(L+3).NE.RJH.OR.JFAC(L).NE.KN/8).AND.RA.NE.4)
03405 1 .OR.RB.LT.RZRO) GO TO 2
03500 IF(RA.EQ.1)GO TO 10
03600 27 IF(RA.GT.4.AND.RA.NE.18.AND.RA.NE.7)GO TO 2
03700 IF(RA.EQ.4.AND.RN(L).GT.2)GO TO 2
03800 C SHOULD CHECK ON BAR LINES NO MATTER WHICH STAFF
03900 10 N=N+1
04000 R(1,N)=RB
04100 IR(2,N)=L
04200 IF(N.EQ.1000)GO TO 28
04300 C ONLY TREATS 1000 ITEMS AT A TIME.
04400
04500
04600 2 CONTINUE
04700
04800 IF(N.EQ.0)GO TO 11
04900 28 KM=JFAC(L)
05000 C SEE FUNCTION JFAC. RSTFAC PNTR.
05100 DO 23 K=1,N
05200 23 IF(RN(IR(2,K)+1).NE.4)GO TO 24
05300 C SKIPS IF ONLY BAR LINES ON THIS STAFF
05400 GO TO 11
05500 24 RSTJC=RSTFAC(KM*8+MQ+4)
05600 CC N=N-1
05700 CALL SORT2(R,N)
05800
05900 C JUMP IF LAST IS A BAR LINE.
06000 K=0
06100 JLDGR=0
06200 JX=0
06300 22 K=K+1
06400 122 L=IR(2,K)
06500 RA=RN(L+1)
06600 RB=0
06700 RX=RN(L+5)
06800 RY=1
06900 RW=AMOD(RN(L+4),100.)
07000 IF(RA.GT.1)GO TO 4
07100 RZ=RN(L+7)
07200 IF(LDGR.NE.JLDGR)JLDGR=0
07300 LDGR=0
07400 JY=K
07500 DO 32 JJ=JY+1,N+1
07600 K=JJ
07700 32 IF(R(1,JJ)-R(1,JJ-1).GT.RSP)GO TO 35
07800 C FOUND HOW MANY MEMBERS TO CHORD.
07900 35 RB=0
08000 K=K-1
08100 RQ=0
08200 RD=0
08300 125 IF(AMOD(RN(L+4),200.).GT.60.)RY=.6
08400 DO 37 JJ=JY,K-1
08500 IF(RD.NE.0)GO TO 38
08600 C FINDS ONLY HIGH OR! LOW LED. LINE.
08700 JIR=IR(2,JJ)
08800 RW=AMOD(RN(JIR+4),100.)
08900 IF(RW.LE.11.AND.RW.GE.2)GO TO 38
09000 LDGR=-1
09100 IF(RW.GT.11)LDGR=1
09200 IF(JLDGR.EQ.LDGR)GO TO 36
09300 JLDGR=LDGR
09400 C LDGR IS FOR LEDGER LINES.
09500 GO TO 38
09600 36 RD=1.5
09700 RQ=RD
09800 38 IF(RB.GT.2)GO TO 222
09900 C JUMP IF LARGE SPACE AFTER NOTE IS ALREADY SET UP.
10000 RZZ=RN(JIR+7)
10100 RE=RN(JIR+5)
10200 IF(RB.LT.2.AND.((AMOD(RZZ,10.).NE.0.AND.RE.LT.20).
10300 1 OR.RZZ.GE.10))RB=1.5+EXTEN(RZZ)
10400 C SPACE FOR DOT OR TAIL(IF STEM UP)
10500 IF(ABS(RN(JIR+6)).EQ.10)RB=RB+2
10600 C FOR CHORD TONES ON RIGHT OF STEM UP.
10700 C LOOKS THROUGH ALL NOTES OF A CHORD.
10800 222 IF(AMOD(RE,10.).EQ.0)GO TO 37
10900 C JUMP IF NO ACCIS.
11000 425 RD=2*RY+EXTEN(RE)
11100 IF(RQ.GT.RD)RD=RQ
11200 RQ=RD
11300 C FUNCT. EXTEN=AMOD(X,1.)*10.
11400 37 CONTINUE
11500 IF(RY.NE.1)RB=RB-.5*RJSZ
11600 C MINI NOTES NEED LESS SPACE
11700 25 IF(JX.GT.0)R(2,JX)=R(2,JX)+RD*RSTJC
11800 GO TO 17
11900 4 IF(RA.NE.3)GO TO 29
12000 RB=3
12100 IF(RX.GT.100)RB=1.5
12200 C CHECK ON SIZE NEEDED FOR CLEFS
12300 29 IF(RA.NE.4)GO TO 26
12400 RB=-RJSZ/2
12500 RD=.9
12600 GO TO 25
12700 26 IF(RA.NE.18)GO TO 30
12800 IF(RW.GT.9.OR.RX.GT.9)GO TO 31
12900 C CHECKS FOR 2-DIGIT METERS
13000 RB=-1
13100 RD=1
13200 GO TO 25
13300 31 RB=2
13400 RD=3
13500 GO TO 25
13600 30 IF(RA.NE.7)GO TO 17
13700 CC RB=2*(ABS(RW)-2)
13800 RB=2*(ABS(RW)-1)-2
13900 RD=2
14000 GO TO 25
14100 C SPACES FOR CORRECT NUM OF ACCIS.
14200 17 RC=(RB+RJSZ)*RSTJC
14300 C RJSZ=DEFAULT SIZE
14400 JX=JX+1
14500 R(2,JX)=RC
14600 R(1,JX)=R(1,K)
14700 3 IF(K.LT.N)GO TO 22
14800 RA=R(1,1)
14900 RB=R(2,1)
15000
15100 DO 13 KX=2,JX
15200 RE=R(1,KX)
15300 C POS. BEFORE SHIFTING
15400 IF(ABS(RE-RA).GT..5)GO TO 14
15500 IF(R(2,KX).GT.RB)GO TO 16
15600 C SKIPS DOUBLE STOPS AND VERY CLOSE ITEMS
15700 GO TO 13
15800 CC IF(RZZ.LE.RB)GO TO 13
15900 C JUMP WHEN SPACE TO ADD IS SMALLER THAN WHAT'S ALREADY THERE
16000 CC RB=RZZ-RB
16100 14 RD=RA+RB-RE
16200 IF(RD.LE.0)GO TO 16
16300 C THERE'S ENOUGH ROOM
16400 CC RD=RA+RB-RE+RD
16500 RJD=RE+RSPC-.001
16600 RJE=1000
16700 C MAYBE MORE? ↑↑↑↑↑
16800 RJH=RD
16900 RJI=0
17000 RSPC=RSPC+RD
17100 C RSPC SAVES TOTAL SPACE ADDED
17200 C GO EXPAND IT
17300 IF(R(2,KX).NE.0)GO TO 166
17400 16 RB=R(2,KX)
17500 13 RA=RE
17600 11 CONTINUE
17700 110 IF(ROV.LE.RRT+.01)GO TO 18
17800 RJD=RZRO
17900 RJE=ROV
18000 RJH=RZRO
18100 RJI=RRT-.001
18200 C JUSTIFYING SPACE DIMINISHES EACH TIME AROUND.
18300 ML=3
18400 IF(RJSZ.GT.4)RJSZ=4
18500 GO TO 66
18600 18 ML=4
18700 RJH=ROV
18800 RJI=RRT+2
18900 C GOES BACK TO PICK UP DANGLING ITEMS(BEYOND RRT)
19000 RJD=ROV
19100 RJE=500
19200 166 JJB=-1
19300 JB=0
19400 66 JY=1
19500 L=JY
19600 IF(RJI.NE.0)RDIS=(RJI-RJH)/(RJE-RJD)
19700
19800 6551 RB=RN(JY)
19900 JB=JB+1
20000 CC IF(RN(JY+3.NE. )GO TO 7551
20100 C IF STAFF#>4, ALL STAVES ARE MOVED.
20200 RA=RN(JY+1)
20300 CC IF(RJF.GT.0.AND.RJF.NE.RA)GO TO 7551
20400 C SKIPS IF NOT SPECIAL CODE NUM.
20500 RN2=RN(JY+2)
20600 IF(RN2.GT.RJE)GO TO 7551
20700 RC=-1
20800 RD=0
20900 IF(RA.EQ.8.OR.RA.EQ.9.OR.RA.EQ.20)RD=-1
21000 IF(RA.EQ.4..OR.RD.OR.RN(JY+5).EQ.50)RC=0
21100 C RC=0 FOR CODES 4,8,9
21200 RN6=RN(JY+6)
21300 IF(RN2.GE.RJD)GO TO 9551
21400 IF(RC.OR.(RC.EQ.0.AND.(RN6.LE.RJD.OR.RN6.GE.RJE)))GO TO 7551
21500 C RIGHT SIDE IS BEFORE OR AFTER MOVE AREA.
21600 9551 IF(JJB)JJB=JB
21700 C (50=CRESC., DECRESC.)
21800 RQ6=RN6-RJE
21900 RX=0
22000 RV=0
22100 IF(RA.NE.9.OR.RB.LT.7)GO TO 21
22200 RX=RN(L+9)
22300 RY=RX-RJE
22400 RZ=RJD-RX
22500 IF(RN(L+10).LT.30)GO TO 221
22600 RW=RN(L+8)
22700 IF(RW.GE.RJD.AND.RW.LE.RJE)RV=-1
22800 221 IF(RY.AND.RZ)RX=-1
22900 C PARTIAL BEAM IS WITHIN MOVE AREA.
23000 21 IF(RJI.EQ.0)GO TO 2551
23100 IF(RN2.GE.RJD)CALL MVBX(RN,2)
23200 IF(RC)GO TO 7552
23300 IF(RA.EQ.4..AND.RB.LT.4)GO TO 7552
23400 IF(RQ6)CALL MVBX(RN,6)
23500 C END POINT OUTSIDE OF MOVE RANGE NOT AFFECTED.
23600 IF(RA.NE.9)GO TO 7552
23700 IF(RX)CALL MVBX(RN,9)
23800 IF(RV)CALL MVBX(RN,8)
23900 C ONLY TRUE WHEN RA=9
24000 GO TO 7552
24100
24200 2551 IF(RN2.GE.RJD)RN2=RN2+RJH
24300 RN(L+2)=RN2
24400 IF(RQ6.AND.(RD.OR.(RA.EQ.4.AND.RB.GT.3.)))RN(L+6)=RN(JY+6)+RJH
24500 IF(RX)CALL MVBEAM(RN,9,JY,L,RJH)
24600 IF(RV)CALL MVBEAM(RN,8,JY,L,RJH)
24700 IF(RN2.GT.ROV)ROV=RN2
24800 C ??? NOT YET FIXED FOR ENDS OF SLURS OR LINES
24900 7552 L=RB+3+L
25000 IF(RJK.EQ.0)GO TO 7551
25100 1551 IF((RB.LT.3..AND.RA.NE.6.AND.RA.NE.11).OR.RA.EQ.18.OR.
25200 1 RA.EQ.10)GO TO 7551
25300 C 'U-D' SKIPS METER, STAFF, KEY SIG., ETC.
25400 JX=JY
25500 CALL MVBEAM(RN,4,JX,JX,RJK)
25600 IF(RC.EQ.0)CALL MVBEAM(RN,5,JX,JX,RJK)
25700 7551 JY=RB+3+JY
25750 L=JY
25800 IF(JY.LT.IX)GO TO 6551
25900 GO TO (16,16,19,101),ML
26000 C ↑↑↑↑↑↑????
26100 101 JJB=1
26200 END
26300
26400 C THESE MOVE ENDS OF PARTIAL INNER BEAMS.
26500 SUBROUTINE MVBEAM(R,I,JY,L,W)
26600 C L AND JY ARE FOR MOVES TO DIFF. STAFF.
26700 DIMENSION R(1)
26800 Y=R(JY+I)
26900 Z=ABS(Y)
27000 IF(Z.LT.100.)GO TO 1
27100 C NEXT FOR MINIS, DIAMONDS, 'X' NOTES. (LIMIT OF +-99 ON ALTITUDE.)
27200 Y=AMOD(Y,100.)
27300 X=Y+W
27400 Z=Z-ABS(Y)+ABS(X)
27500 C PUTS ALL INTO POSITIVE
27600 IF(X)Z=-Z
27700 GO TO 2
27800 1 Z=Y+W
27900 2 R(L+I)=Z
28000 END
28100
28200 SUBROUTINE MVBX(R,I)
28300 COMMON JY,L,RJH,RJD,RDIS
28400 DIMENSION R(1)
28500 R(L+I)=RJH+(R(JY+I)-RJD)*RDIS
28600 END
28700
28800 SUBROUTINE EXCH(X,Y)
28900 Z=X
29000 X=Y
29100 Y=Z
29200 END
29300 SUBROUTINE SORT2(RPOS,M)
29400 DIMENSION RPOS(2,1000)
29500 L=2
29600 3 J=-1
29700 RX=RPOS(1,L-1)
29800 DO 2 K=L,M
29900 IF(RPOS(1,K).GE.RX)GO TO 2
30000 RX=RPOS(1,K)
30100 C WHY WERE ALL THE RX'S JX ????? 9/6/73
30200 J=K
30300 2 CONTINUE
30400 IF(J)GO TO 4
30500 K=L-1
30600 CALL EXCH(RPOS(1,K),RPOS(1,J))
30700 CALL EXCH(RPOS(2,K),RPOS(2,J))
30800 4 L=L+1
30900 IF(L.LE.M)GO TO 3
31000 END
31100
31200 FUNCTION EXTEN(X)
31300 EXTEN=AMOD(X,1.)*10.
31400 END
31500
31600 FUNCTION JFAC(L)
31700 C FINDS RSTFAC POINTER
31800 CC COMMON /RS/JW(80)
31810 COMMON/Q/ RN(20000),PWDS(2500),V(200)
31855 1,RSTFAC(120),STFF(120),R(2,1500),JR(120),P1,P2,I,M
31900 K=0
32000 CC R=L
32100 1 K=K+1
32200 IF(L.GE.JR(K))GO TO 1
32300 JFAC=K-2
32400 END